let fun_list = Hashtbl.create 42 and var_list = Hashtbl.create 42

open Types
(*
(** Création d'un module Hash fonctionnel *)
module Ord = struct type t = string let compare = Pervasives.compare end
module Hash = Map.Make (Ord)
*)
(** Liste des variables et des fonctions et leur types. *)


(** On rajoute le type des fonctions par defaut.*)
let initialise () = 
  Hashtbl.add fun_list "if" ([TBOOL; TPOL 0; TPOL 0], TPOL 0);
  Hashtbl.add fun_list "==" ([TPOL 0; TPOL 0], TBOOL);
  Hashtbl.add fun_list "+" ([TNUM; TNUM], TNUM);
  Hashtbl.add fun_list "-" ([TNUM; TNUM], TNUM);
  Hashtbl.add fun_list "*" ([TNUM; TNUM], TNUM);
  Hashtbl.add fun_list "/" ([TNUM; TNUM], TNUM);
  Hashtbl.add fun_list "%" ([TNUM; TNUM], TNUM);
  Hashtbl.add fun_list "^" ([TNUM; TNUM], TNUM);
  Hashtbl.add fun_list "++" ([TSTRING; TSTRING], TSTRING);
  Hashtbl.add fun_list "||" ([TBOOL; TBOOL], TBOOL);
  Hashtbl.add fun_list "&&" ([TBOOL; TBOOL], TBOOL);

  Hashtbl.add fun_list "print" ([TPOL 0], TUNIT);
  Hashtbl.add fun_list "scan" ([TUNIT], TSTRING);
  Hashtbl.add fun_list "num" ([TSTRING], TNUM);
  Hashtbl.add fun_list "string" ([TNUM], TSTRING)
;;
(** 
   Compare deux definitions de type deux a deux.
   a : definition de la fonction; b : definition des arguments passes a la fonction
*)

let compare a b =
  let rec uniq_list l  =
    let rec aux l = function
      | [] -> l
      | a::b -> aux (if List.mem a l then l else a::l) b
    in List.rev (aux [] l)
  in
  let rec assos_pol =  function
    | ([], []) -> []
    | (TPOL n::la), (a::lb)  -> (TPOL n, a)::(assos_pol (la,lb))
    | (a::la), (TPOL n::lb)  -> (TPOL n, a)::(assos_pol (la,lb))
    | (_::a),( _::b) -> assos_pol (a,b)
    | _ -> failwith "error"
  in
  let compare_e t  = function
    | (TPOL n, e) -> t.(n) = e
    | (a, b) -> a = b
  in
  let ta,tb = List.length a, List.length  b in
    if ta <> tb then false
    else
      try
        let pol = Array.of_list (List.map snd (uniq_list (assos_pol (a, b)))) in
        let l = List.combine a b in
          List.fold_left (&&) true (List.map (fun x -> compare_e pol x) l)                                    
      with _ -> false

(** Convertit un lex en tlex *)
let get_type = function
    NUM _ -> TNUM
  | BOOL _ -> TBOOL
  | FUN _ -> TFUN
  | VAR _ -> TVAR
  | UNIT _ -> TUNIT
  | STRING _ -> TSTRING


let concat_string = function
  | [] -> ""
  | a::b -> List.fold_left ( fun x y -> x ^" -> "^ y ) a b

let format_error f a b =
  let typea = concat_string (List.map (print_tlex) a) and typeb = concat_string (List.map (print_tlex) b) in
    ("Bad types with function "^f^" : "^f^" have type "^typea^" but it here use with type "^typeb, 
     "La fonction "^f^" est utilisée avec un type incorrecte : "^f^" a le type "^typea^", mais elle est ici utilisée avec le type "^typeb)


let find_vars e l = 
  snd (List.find (fun x -> (fst x) = e) l)

let rec type_tree vars = function
  | Leaf(VAR v, err) ->  (try find_vars v vars with _ -> Helper.find_h var_list v  (("Unknow "^v), (v^" est inconnue")) err)
  | Leaf(e, err) -> get_type e
  | Node ((FUN f, err), l) ->
      let args = List.map (type_expr vars) l in
      let type_f = Helper.find_h fun_list f (("Unknow function "^f), ("Fonction "^f^" inconnue")) err  in
        if not (compare (fst type_f) args) then Helper.fail (format_error f (fst type_f) args) err
        else snd type_f
  | Node ((_, e), _) -> Helper.fail ("Syntax error", "Erreur de syntaxe") e

and type_expr vars l = 
  List.hd (List.rev (List.map (type_tree vars) l))


(** Affiche une signature de fonction. a : liste de types d'entree, b: liste de types de sortie.   *)
let view_tf a b =
  let typea = concat_string (List.map (print_tlex) a) and typeb = print_tlex b in
   typea^" : "^typeb


let get_type_f f = 
  let a,b = Hashtbl.find fun_list f in
    view_tf a b

let find_type_of_var nf f vars = 
  let type_var = Hashtbl.create 5 in
  let rec initialise_type_var n = function
    | [] -> ()
    | t::l -> Hashtbl.add type_var t (TPOL n); initialise_type_var (n+1) l
  in
  let rec list_of_hashtbl = function
    | [] -> []
    | h::t -> (Hashtbl.find type_var h)::(list_of_hashtbl t)
  in
  let get_l_n = fun n -> List.map (fun x -> TPOL x) (Array.to_list (Array.init (n+1) (fun i -> i))) in 
  let compare_t = function
    | (TPOL a, TPOL b) -> TPOL (min a b)
    | (TPOL n, b) -> b
    | (a, TPOL n) -> a
    | (a,b) -> a
  in
  
  let rec aux nf tec = function
    | Leaf(VAR v, err) -> Hashtbl.replace type_var v (compare_t (tec, Hashtbl.find type_var v))
    | Node((FUN f, err), l) ->
	let nl = List.map (fun x -> List.hd (List.rev x)) l in
	    let ta = if f = nf then list_of_hashtbl vars
	             else
	               try  fst (Helper.find_h fun_list f (("Unknow function "^f), ("Fonction "^f^" inconnue")) err)
		       with _ ->  get_l_n (List.length l - 1)
	    in
	    let la = List.combine ta nl in
	      List.iter (fun x -> let a,b = x in aux nf a b) la
    | _ -> ()
  and expr_aux nf tec l =
    List.iter (fun x -> aux nf tec x) l
  in

    (*
  let rec unifie type_en_cours = function
    | Leaf(VAR e) -> (e, type_en_cours)
    | Leaf e -> ("", get_type e)
    | Node((FUN f, err), largs) ->
	let args = List.hd largs in
	let tinput, toutput =  Helper.find_h fun_list f (("Unknow function "^f), ("Fonction "^f^" inconnue")) err in
	let l = List.combine tinput args in
	let nl = List.map (fun x -> unifie (fst x) (snd x)) l in
	  (* Liste sous la forme : [TBOOL, ("", TBOOL); (TPOL 0, ("x", TPOL 0)); (TPOL 0, ("", TNUM)); ...]*)
	(* On rajoute le type de sortie de la fonction dedans (si ça peut aider...) *)
	let nl = (toutput, ("", spec(toutput, type_en_cours)))::nl in
	  (* On unifie la liste on supprimant les POL 0 *)
	let nl = specifie nl in
	  (* Liste sous la forme : [("", TNUM); ("", TBOOL)); ("x", TNUM); ...]*)
	  (* On assigne les valeurs et leur nouveau type dans le hashtbl : *)
	  assign nl;
	  (* On renvoit le type de retour de la fonction *)
	  snd (List.hd nl)

  in
    *)
    initialise_type_var 0 vars; expr_aux nf (TPOL 0) f; 
    let l = list_of_hashtbl vars in
    (l, type_expr (List.combine vars l) f )


(*
  Les deux fonctions typent l'ensemble du programme.
  Les fonctions ne sont pas encore typées.
*)

let rec type_e = function
  | [] -> ()
  | (Expr e)::l -> ignore (type_expr [] e); type_e l
  | (Def (s, t))::l -> Hashtbl.add var_list s (type_expr [] t);  type_e l
  | (DFun (n, args, t))::l -> Hashtbl.add fun_list n (find_type_of_var n t args); type_e l

let type_prog p = 
  type_e p

